signature SEMANT =
sig 
    val transProg : Absyn.exp -> Translate.frag list
end

structure Semant : SEMANT =
struct
  structure A = Absyn
  structure E = ErrorMsg
  structure M = Temp
  structure R = Tree
  structure S = Symbol
  structure T = Types
  structure U = UnparseAbsyn
  structure V = Env
  structure X = Translate
		
  val xlNil = X.Ex R.ZERO
  val xlBad = xlNil

  fun xlRelOp A.EqOp  = R.EQ
    | xlRelOp A.NeqOp = R.NE
    | xlRelOp A.LtOp  = R.LT
    | xlRelOp A.LeOp  = R.LE
    | xlRelOp A.GtOp  = R.GT
    | xlRelOp A.GeOp  = R.GE
    | xlRelOp oper    = E.impossible ("CONVERTING NON-COMPARISON OPERATOR: " ^ (U.unparseOp oper))

  fun xlArithOp A.PlusOp   = R.PLUS
    | xlArithOp A.MinusOp  = R.MINUS
    | xlArithOp A.TimesOp  = R.MUL
    | xlArithOp A.DivideOp = R.DIV
    | xlArithOp oper       = E.impossible ("CONVERTING ARITHMETIC OPERATOR: " ^ (U.unparseOp oper))

  fun xlIntComp (oper, expl, expr) = X.Cx (fn (t, f) => R.CJUMP (xlRelOp oper, expl, expr, t, f))
					
  fun xlIfThenElse (test, X.Nx then', X.Nx else') = let val t = M.newlabel ()
							val f = M.newlabel ()
							val e = M.newlabel ()
						    in X.Nx (R.seq [           (X.unCx test) (t, f),
								    R.LABEL f, else'               ,
									       R.jump e            ,
								    R.LABEL t, then'               ,
								    R.LABEL e                      ])
						end
    | xlIfThenElse (test,    then',    else') = let val t = M.newlabel ()
						    val f = M.newlabel ()
						    val e = M.newlabel ()
						    val r = R.TEMP (M.newtemp ())
						in X.Ex (R.eseq ([           (X.unCx test) (t, f)      ,
								  R.LABEL f, R.MOVE (r, (X.unEx else')),
								 	     R.jump e                  ,
								  R.LABEL t, R.MOVE (r, (X.unEx then')),
								  R.LABEL e                            ],
								 r))
					  end

  fun xlIfThen (test, X.Cx then') = let val z = M.newlabel ()
				    in X.Cx (fn (t,f) => R.seq [           (X.unCx test) (z, f),
								R.LABEL z, then' (t, f)        ])
				    end
    | xlIfThen (test,    then') = let val t = M.newlabel ()
				      val f = M.newlabel ()
				  in X.Nx (R.seq [           (X.unCx test) (t, f),
						  R.LABEL t, (X.unNx then')      ,
						  R.LABEL f                      ])
				  end
					   
  fun typeError pos msg = E.error pos ("type error: " ^ msg)

  fun binaryTypeError pos tyl tyr preMsg postMsg = ( typeError pos ("incompatible" ^ preMsg ^ "types, "
								    ^ (U.unparseTy (tyl, 0)) ^ " and "
								    ^ (U.unparseTy (tyr, 0)) ^ ", in " ^ postMsg)
						   ; false
						   )
			  
  fun checkDups (s, []) = ()
    | checkDups (s, (n,p)::nps) = ( case List.find (fn (n',_) => n=n') nps
				     of NONE => ()
				      | SOME (n',p') => typeError p ("duplicate " ^ s
								     ^ " '" ^ (S.name n) ^ "'"
								     ^ " @" ^ E.getLinePos(p'))
				  ; checkDups (s, nps) )
				  
  type expty = { exp : X.exp
	       , ty : T.ty }
	       

				      
  fun checkInt (T.INT, _,   _)   = true
    | checkInt (ty,    pos, msg) = ( typeError pos ("int required in " ^ msg
						    ^ ", got " ^ (U.unparseTy (ty, 0)))
				   ; false
				   )
				   
  fun checkUnit (T.UNIT, _,   _)   = true
    | checkUnit (ty,     pos, msg) = ( typeError pos ("unit required in " ^ msg
						      ^ ", got " ^ (U.unparseTy (ty, 0)))
				     ; false
				     )
				     
  fun checkNotNil (T.NIL, pos, msg) = ( typeError pos ("illegal untyped nil in " ^ msg)
				      ; false
				      )
    | checkNotNil (_,     _,   _)   = true
				      

  (* :=, var *)
  fun checkAssignable (       T.INT,                  T.INT,            _,     _) = true
    | checkAssignable (       T.STRING,               T.STRING,         _,     _) = true
    | checkAssignable (       T.RECORD (_, _),        T.NIL,            _,     _) = true
    | checkAssignable (       T.NIL,                  T.RECORD (_, _),  _,     _) = true
    | checkAssignable (       T.NIL,                  T.NIL,            pos, msg) = ( typeError pos ("illegal untyped nil in " ^ msg)
										    ; false
										    )
    | checkAssignable (tyl as T.RECORD (_, u), tyr as T.RECORD (_, u'), pos, msg) = (u = u') orelse binaryTypeError pos tyl tyr " record " msg
    | checkAssignable (tyl as T.ARRAY  (_, u), tyr as T.ARRAY  (_, u'), pos, msg) = (u = u') orelse binaryTypeError pos tyl tyr " record " msg
    | checkAssignable (tyl,                    tyr,                     pos, msg) = binaryTypeError pos tyl tyr " " msg
								      
  exception NotComparable

  (* <, <=, >, >= *)
  fun tryComparable ({exp=expl, ty=T.INT},    {exp=expr, ty=T.INT},    oper) = { exp = xlIntComp (oper, X.unEx expl, X.unEx expr)
									       , ty = T.INT }
    | tryComparable ({exp=expl, ty=T.STRING}, {exp=expr, ty=T.STRING}, oper) = { exp = xlIntComp (oper, X.externalCall ("strcmp",
															[X.unEx expl, X.unEx expr]),
												        R.ZERO)
									       , ty = T.INT }
    | tryComparable (_,                       _,                       oper) = raise NotComparable

  fun xlComparable (exptyl as {exp=_, ty=tyl}, exptyr as {exp=_, ty=tyr}, oper, pos) = tryComparable (exptyl, exptyr, oper)
										       handle NotComparable => ( binaryTypeError pos tyl tyr " " (U.unparseOp oper)
													       ; { exp = xlBad
														 , ty = T.INT }
													       )

  (* pointers are integers *)
  fun xlEqualable (exptyl as {exp=expl, ty=tyl}, exptyr as {exp=expr, ty=tyr}, oper, pos) = tryComparable (exptyl, exptyr, oper)
                                                                                            handle NotComparable => { exp = if checkAssignable (tyl, tyr, pos, U.unparseOp oper)
															    then xlIntComp (oper, X.unEx expl, X.unEx expr)
															    else xlBad
														    , ty = T.INT }

  fun xlArith ({exp=expl, ty=T.INT}, {exp=expr, ty=T.INT}, oper,   _) = { exp = X.Ex (R.BINOP ((xlArithOp oper), X.unEx expl, X.unEx expr))
									, ty = T.INT }
    | xlArith ({exp=_,    ty=T.INT}, _,                    oper, pos) = ( typeError pos ("left operand not integer to " ^ (U.unparseOp oper))
									; { exp = xlBad
									  , ty = T.INT }
									)
    | xlArith (_,                    {exp=_,    ty=T.INT}, oper, pos) = ( typeError pos ("right operand not integer to " ^ (U.unparseOp oper))
									; { exp = xlBad
									  , ty = T.INT }
									)
    | xlArith (_,                    _,                    oper, pos) = ( typeError pos ("non-integer operands to " ^ (U.unparseOp oper))
									; { exp = xlBad
									  , ty = T.INT }
									)

  fun morePreciseTy (ty as T.RECORD (_, _),       T.NIL)             = ty
    | morePreciseTy (      T.NIL,           ty as T.RECORD (_, _))   = ty
    | morePreciseTy (ty,                    _ )                      = ty
								       
  (* function return, IF consequents *)
  fun checkEqual (T.UNIT, T.UNIT, pos, msg) = true
    | checkEqual (tyl,    tyr,    pos, msg) = checkAssignable (tyl, tyr, pos, msg)
					      
  fun lookupRawTy (tenv, typ, pos, msg) = case S.look (tenv, typ)
					   of NONE => ( typeError pos (msg ^ " type not defined: " ^ (S.name typ))
						      ; T.UNIT )
					    | SOME ty => ty
										
  fun actualTy (T.NAME (_, t)) = (case !t
				   of NONE => ( E.impossible "TYPE NOT COMPLETED"
					      ; T.UNIT )
				    | SOME ty => let val ty = actualTy (ty)
						 in ( t := SOME ty
						    ; ty )
						 end)
    | actualTy ty = ty
		    
  fun lookupTy (tenv, typ, pos, msg) = actualTy (lookupRawTy (tenv, typ, pos, msg))
				       
  (* transTy : tenv * A.ty -> T.ty *)
  fun transTy (tenv, A.NameTy (typ, pos)) = lookupRawTy (tenv, typ, pos, "named")
					    
    | transTy (tenv, A.RecordTy fs) = ( checkDups ("field name", map (fn {name,escape,typ,pos} => (name, pos)) fs)
				      ; T.RECORD (map (fn {name,escape,typ,pos} => (name, lookupRawTy (tenv, typ, pos, "field"))) fs,
						  ref ())
				      )
				      
    | transTy (tenv, A.ArrayTy (typ, pos)) = T.ARRAY (lookupRawTy (tenv, typ, pos, "array element"), ref ())
					     
  (* transDec : (dec * (venv, tenv, level, break)) -> (venv, tenv, exp option) *)
  and transDec (A.VarDec{name,escape,typ,init,pos}, (venv, tenv, level, break)) = let val {exp=expi,ty=tyi} = transExp (venv, tenv, level, break) init
										      val access = X.allocLocal level (!escape)
										  in (S.enter (venv,
											       name, 
											       case typ
												of NONE => ( checkNotNil (tyi, pos, "inferred variable type")
													   ; V.VarEntry{ access = access
														       , ty = tyi }
													   )
												 | SOME (typ, pos') => let val tyv = lookupTy (tenv, typ, pos', "variable")
														       in ( checkAssignable (tyi, tyv, pos, "variable initializer")
															  ; V.VarEntry{ access = access
																      , ty = morePreciseTy (tyv, tyi) }
															  )
														       end),
										      tenv,
										      SOME (X.Nx (R.MOVE (X.genAccess (access, level), X.unEx expi))))
										  end
										  
    | transDec (A.TypeDec nts, (venv, tenv, level, break)) = ( checkDups ("type", map (fn {name,ty,pos} => (name,pos)) nts)
							     ; let val tenv = foldl (fn ({name,ty,pos}, tenv) => S.enter (tenv,
															  name,
															  T.NAME (name, ref NONE)))
										    tenv
										    nts
								   val chainLen = (length nts)
							       in ( app (fn {name,ty,pos} => case S.look (tenv, name)
											      of SOME (T.NAME (_, t)) => t := SOME (transTy (tenv, ty))
											       | _ => E.impossible "MISSING TYPE INCONSISTENCY")
									nts
								  ; app (fn {name,ty,pos} => let fun walkTy (0, T.NAME (_, _)) = typeError pos ("cyclic type found at: " ^ (S.name name))
												   | walkTy (d, T.NAME (_, t)) = (case !t
																   of NONE => E.impossible ("INCOMPLETE TYPE " ^ (S.name name))
																    | SOME ty => walkTy (d-1, ty))
												   | walkTy (_, ty) = ()
											     in walkTy (chainLen, lookupRawTy (tenv, name, pos, "recursive"))
											     end)
									nts
								  ; (venv, tenv, NONE) )
							       end
							     )
					       
    | transDec (A.FunctionDec nfs, (venv, tenv, level, break)) = ( checkDups ("function", map (fn {name,params,result,body,pos} => (name, pos)) nfs)
								 ; let val venv = foldl (fn ({name,params,result,body,pos}, venv) => let val l = M.newlabel()
																     in S.enter (venv,
																		 name,
																		 V.FunEntry {level = X.newLevel { formals = map (fn {name,escape,typ,pos} => !escape) params
																						, name = l
																						, parent = level },
																			     label = l,
																			     formals = map (fn {name,escape,typ,pos} => lookupTy (tenv, typ, pos, "argument")) params,
																			     result = case result
																				       of NONE => T.UNIT
																					| SOME (typ, pos) => lookupTy (tenv, typ, pos, "result") })
																     end)
											venv
											nfs
								   in ( let fun checkFun ({level,label,formals,result}, params, body, pos) = ( checkDups ("argument", map (fn {name,escape,typ,pos} => (name, pos)) params)
																		  ; let val venv = (ListPair.foldlEq (fn ({name,escape,typ,pos}, tyf, venv) => S.enter (venv,
																													name,
																													V.VarEntry { access = X.allocLocal level (!escape)
																														   , ty = tyf }))
																						     venv
																						     (params, formals)
																				    handle ListPair.UnequalLengths => E.impossible "FUNCTION ARGS INCONSISTENCY")
																		    in let val {exp=expb, ty=tyb} = transExp (venv, tenv, level, NONE) body
																		       in if checkEqual (result, tyb, pos, "function return")
																			  then case result
																				of T.UNIT => X.registerProc (level, X.unNx expb)
																				 | _ => X.registerProc (level, R.MOVE (X.retVal, X.unEx expb))
																			  else X.registerProc (level, R.LABEL (M.newlabel ()))
																		       end
																		    end
																		  )
									in app (fn {name,params,result,body,pos} => case S.look (venv, name)
														     of SOME (V.FunEntry ve) => checkFun (ve, params, body, pos)
														      | _ => E.impossible "MISSING FUNCTION INCONSISTENCY")
									       nfs
									end
								      ; (venv, tenv, NONE)
								      )
								   end
								 )
								 
  (* transExp : (venv, tenv, level, break) -> exp -> expty *)
  and transExp (venv, tenv, level, break) =
      (* trExp : exp -> expty *)
      let fun trExp A.NilExp = { exp = xlNil
			       , ty = T.NIL }
	    | trExp (A.IntExp i) = { exp = X.Ex (R.CONST i)
				   , ty = T.INT }
	    | trExp (A.StringExp (s, _)) = { exp = let val label = M.newlabel ()
						   in ( X.registerString (label, s)
						      ; X.Ex (R.NAME label)
						      )
						   end
					   , ty = T.STRING }
				      
	    | trExp (A.OpExp{left,oper,right,pos}) = let val exptyl = trExp left
							 val exptyr = trExp right
						     in case oper
							 of A.PlusOp   => xlArith (exptyl, exptyr, oper, pos)
							  | A.MinusOp  => xlArith (exptyl, exptyr, oper, pos)
							  | A.TimesOp  => xlArith (exptyl, exptyr, oper, pos)
							  | A.DivideOp => xlArith (exptyl, exptyr, oper, pos)

							  | A.EqOp  => xlEqualable (exptyl, exptyr, oper, pos)
							  | A.NeqOp => xlEqualable (exptyl, exptyr, oper, pos)

							  | A.LtOp => xlComparable (exptyl, exptyr, oper, pos)
							  | A.LeOp => xlComparable (exptyl, exptyr, oper, pos)
							  | A.GeOp => xlComparable (exptyl, exptyr, oper, pos)
							  | A.GtOp => xlComparable (exptyl, exptyr, oper, pos)
						     end
						     
	    | trExp (A.IfExp{test,then',else'=NONE,pos}) = let val {exp=expt, ty=tyt} = trExp test
							       val {exp=expn, ty=tyn} = trExp then'
							   in let val testOK = checkInt (tyt, pos, "IF test")
								  val consqOK = checkUnit (tyn, pos, "IF  consequent")
							      in { exp = if testOK andalso consqOK
									 then xlIfThen (expt, expn)
									 else xlBad
								 , ty = tyn }
							      end
							   end
	      
	    | trExp (A.IfExp{test,then',else'=SOME else',pos}) = let val {exp=expt, ty=tyt} = trExp test
								     val {exp=expn, ty=tyn} = trExp then'
								     val {exp=expe, ty=tye} = trExp else'
								 in let val testOK = checkInt (tyt, pos, "IF test")
									val consqOK = checkEqual (tyn, tye, pos, "IF consequents")
								    in
									{ exp = if testOK andalso consqOK
										then xlIfThenElse (expt, expn, expe)
										else xlBad
									, ty = morePreciseTy (tyn, tye) }
								    end
								 end
	      
	    | trExp (A.WhileExp{test,body,pos}) = let val break = M.newlabel()
						  in let val {exp=expt, ty=tyt} = trExp test
							 val {exp=expb, ty=tyb} = transExp (venv, tenv, level, SOME break) body
						     in let val testOK = checkInt (tyt, pos, "WHILE test")
							    val bodyOK = checkUnit (tyb, pos, "WHILE body")
							in { exp = if testOK andalso bodyOK
								   then let val top = M.newlabel ()
									    val inner = M.newlabel ()
									in X.Nx (R.seq [R.LABEL top,   (X.unCx expt) (inner, break),
											R.LABEL inner, (X.unNx expb)               ,
										                       R.jump top                  ,
											R.LABEL break                              ])
									end
								   else xlBad
							   , ty = T.UNIT }
							end
						     end
						  end

	    | trExp (A.BreakExp pos) = { exp = case break
						of NONE => ( typeError pos "break not in for/while"
							   ; xlBad
							   )
						 | SOME break => X.Nx (R.jump break)
				       , ty = T.UNIT }
				       
	    | trExp (A.ForExp _) = E.impossible "FOR EXPRESSION PASSED THROUGH"

	    | trExp (A.SeqExp []) = { exp = xlNil
				    , ty = T.UNIT }
	    | trExp (A.SeqExp [(exp, pos)]) = ( typeError pos "sequence of one expression"
					      ; trExp exp )
	    | trExp (A.SeqExp ((exp,_)::exps)) = foldl (fn ((exp,_), {exp=exps,ty=_}) => let val {exp, ty} = trExp exp
											 in { exp = X.Ex (R.ESEQ (X.unNx exps, X.unEx exp))
											    , ty = ty }
											 end)
						       (trExp exp)
						       exps
						   
	    | trExp (A.VarExp var) = trVar var
				     
	    | trExp (A.AssignExp{var,exp,pos}) = let val {exp=expv, ty=tyv} = trVar var
						     val {exp=expe, ty=tye} = trExp exp
						 in { exp = if checkAssignable (tyv, tye, pos, "assignment")
							    then X.Nx (R.MOVE (X.unEx expv, X.unEx expe))
							    else xlBad
						    , ty = T.UNIT }
						 end
						 
	    | trExp (A.CallExp{func,args,pos}) = let val exptys = map trExp args
						 in case S.look (venv, func)
						     of SOME (V.FunEntry{level=level',label,formals,result}) => { exp = ( ListPair.appEq (fn ({exp=_, ty=tya}, tyf) => ignore (checkAssignable (tya, tyf, pos, "function argument")))
																	 (exptys, formals)
															; let val aexps = X.addStatic (level',
																		       level,
																		       map (fn {exp, ty} => X.unEx exp) exptys)
															  in X.Ex (R.CALL (R.NAME label,
																	   aexps))
															  end
															) handle ListPair.UnequalLengths => ( typeError pos "wrong number of arguments"
																			    ; xlBad
																			    )
														, ty = result }
						      | _ => ( typeError pos ("undefined function: " ^ (S.name func))
							     ; { exp = xlBad
							       , ty = T.UNIT }
							     )
						 end
						 
	    | trExp (A.ArrayExp{typ,size,init,pos}) = let val {exp=expn, ty=tyn} = trExp size
							  val {exp=expi, ty=tyi} = trExp init
						      in ( checkInt (tyn, pos, "array size")
							 ; case lookupTy (tenv, typ, pos, "array")
							    of tya as (T.ARRAY (tye, _)) => { exp = if checkAssignable (actualTy tye, tyi, pos, "array element")
												    then let val arr = R.TEMP (M.newtemp ())
													     val cnt = R.TEMP (M.newtemp ())
													 in X.Ex (R.eseq ([R.MOVE (cnt, X.unEx expn)                                     ,
															   R.MOVE (arr, X.externalCall ("allocWords"                     ,
																			[R.BINOP (R.PLUS, cnt, R.ONE)])) ,
															   R.MOVE (arr, cnt)                                             ,
															   R.EXP (X.externalCall ("copyMem"                              ,
																		  [X.arrStart arr           ,
																		   cnt                      ,
																		   X.unEx expi]))                        ],
															  arr))
													 end
												    else xlBad
											    , ty = tya }
							     | _ => ( typeError pos ("not an array type for creation: " ^ (S.name typ))
								    ; { exp = xlBad
								      , ty = T.ARRAY (tyi, ref ()) }
								    )
							 )
						      end

	     | trExp (A.RecordExp{fields,typ,pos}) = let fun getType (name', pos, [], nts') = ( typeError pos ("no such field: " ^ (S.name name'))
											      ; (T.UNIT, nts'))
							   | getType (name', pos, (name, ty)::nts, nts') = if name' = name
													   then (actualTy ty, nts@nts')
													   else getType (name', pos, nts, (name, ty)::nts')
						     in case lookupTy (tenv, typ, pos, "record")
							 of tyr as T.RECORD (nts,_) => (case foldl (fn (f as (name, {exp=exp, ty=tya}, pos, fnum), (xns, nts)) => let val (tyf, nts) = getType (name, pos, nts, [])
																				  in ( checkAssignable (tya, tyf, pos, "record field")
																				     ; (((exp, fnum)::xns), nts)
																				     )
																				  end)
												   ([], nts)
												   let val (_, fs) = foldl (fn ((name, exp, pos), (n, fs)) => (n+1, (name, trExp exp, pos, n)::fs))
															   (0, [])
															   fields
												   in fs
												   end
											 of (xns, []) => { exp = let val r = R.TEMP (M.newtemp ())
														 in X.Ex (R.eseq (R.MOVE (r, X.externalCall ("allocWords",
																			     [R.CONST (length xns)]))
																  :: (map (fn (exp, fnum) => R.MOVE (X.offset (r, fnum), X.unEx exp))
																	  xns),
																  r))
														end
													, ty = tyr }
											  | (_, nts) => ( typeError pos ("uninitialized fields: " ^ (U.commaSep (map (fn (name,_) => S.name name) nts)))
													; { exp = xlBad
													  , ty = tyr }
													))
							  | _ => ( typeError pos ("record type required: " ^ (S.name typ))
								 ; { exp = xlBad
								   , ty = T.RECORD ([], ref ()) } )
						     end
						    
	    | trExp (A.LetExp{decs,body,pos}) = let val (venv, tenv, exps) = foldl trDec (venv, tenv, []) decs
						in let val {exp=expb, ty} = transExp (venv, tenv, level, break) body
						   in { exp = case exps
							       of [] => expb
								| _  => X.Ex (R.eseq ((map X.unNx exps),
										      X.unEx expb))
						      , ty=ty }
						   end
						end
						
	  (* trDec : (dec, (venv, tenv, exp list) -> (venv, tenv, exp list) *)
	  and trDec (dec, (venv, tenv, exps)) = case transDec (dec, (venv, tenv, level, break))
						 of (venv, tenv, NONE) => (venv, tenv, exps)
						  | (venv, tenv, SOME exp) => (venv, tenv, exps@[exp])

	  (* trVar : var -> expty  -- yields an R.MEM expression for use as an lvalue or an r-value *)
	  and trVar (A.SimpleVar(id,pos)) = (case S.look (venv, id)
					      of SOME (V.VarEntry{access,ty}) => { exp = X.Ex (X.genAccess (access, level))
										 , ty = actualTy ty }
					       | _ => ( typeError pos ("undefined variable: " ^ (S.name id))
						      ; { exp = xlBad
							, ty = T.UNIT }
						      ))
					    
	    (* record is [field 0, field 1, ...] in order of declaration *)
	    | trVar (A.FieldVar(var,id,pos)) = let val {exp=expv, ty=tyv} = trVar var
					       in case tyv
						   of T.RECORD (sts,_) => let fun findField (_, []) = ( typeError pos ("record missing field: " ^ (S.name id))
												      ; { exp = xlBad
													, ty = T.UNIT } )
										| findField (n, (id',ty')::sts) = if id' = id
														  then { exp = let val r = R.TEMP (M.newtemp ())
																   val t = M.newlabel ()
																   val f = M.newlabel ()
															       in X.Ex (R.eseq ([           R.MOVE (r, X.unEx expv)                     ,
																			    R.CJUMP (R.NE, r, R.ZERO, t, f)             ,
																		 R.LABEL f, R.EXP (X.externalCall ("nilRecordPtr", [])) , (* never to return *)
																		 R.LABEL t                                              ],
																		X.offset (r, n)))
															       end
														       , ty = actualTy ty' }
														  else findField (n+1, sts)
									  in findField (0, sts)
									  end
						    | _ => ( typeError pos ("record required for field " ^ (S.name id))
							   ; { exp = xlBad
							     , ty = T.UNIT }
							   )
					       end
					       
	    (* array is [length, item 0, item 1, ... ] *)
	    | trVar (A.SubscriptVar(var,sub,pos)) = let val {exp=expv, ty=tyv} = trVar var
							val {exp=expi, ty=tyi} = trExp sub
						    in case tyv
							of T.ARRAY (ty,_) => { exp = if checkInt (tyi, pos, "array subscript")
										     then let val a = R.TEMP (M.newtemp ())
											      val i = R.TEMP (M.newtemp ())
											      val t = M.newlabel ()
											      val f = M.newlabel ()
											  in X.Ex (R.eseq ([           R.MOVE (a, X.unEx expv)                        ,
														       R.MOVE (i, X.unEx expi)                        ,
														       R.CJUMP (R.LE, i, R.MEM a, t, f)               ,
													    R.LABEL f, R.EXP (X.externalCall ("arrayOutOfBounds", [])), (* never to return *)
													    R.LABEL t                                                 ],
													   X.index(a, R.BINOP (R.PLUS, i, R.ONE))))
											  end
										     else xlBad
									     , ty = actualTy ty }
							 | _ => ( typeError pos "array required"
								; checkInt (tyi, pos, "array subscript")
								; { exp = xlBad
								  , ty = T.UNIT }
								)
						    end
      in trExp
      end
      
  (* A.exp -> X.frag list *)
  fun transProg exp = ( X.initResult ()
		      ; let val {exp=prog, ty=ty} = transExp (V.base_venv, V.base_tenv, X.outermost, NONE)
							     exp
			in ( X.registerProc (X.outermost, X.unNx prog)
			   ; TextIO.output (TextIO.stdErr, "program has type: " ^ (U.unparseTy (ty, 10))  ^ "\n")
			   )
			end
		      ; X.getResult ()
		      )


end
